Shareware Grab Bag/Shareware Grab Bag.iso/001/pibcalc.arc/ARITH.PAS

Pascal/Delphi Source File | 1985-03-08 | 8KB | 268 lines

(*--------------------------------------------------------------------------*)
(*                  ARITH.PAS --- basic arithmetic routines                 *)
(*                                                                          *)
(*    Routines included:                                                    *)
(*                                                                          *)
(*       AddVals  --- add two values                                        *)
(*       SubVals  --- subtract two values                                   *)
(*       MulVals  --- multiply two values                                   *)
(*       DivVals  --- divide two real values                                *)
(*       IdivVals --- Integer divide                                        *)
(*       ModVals  --- MOD operation                                         *)
(*       PowVals  --- exponentiation operation                              *)
(*                                                                          *)
(*--------------------------------------------------------------------------*)


(*--------------------------------------------------------------------------*)
(*                     AddVals --- Add two values                           *)
(*--------------------------------------------------------------------------*)

PROCEDURE AddVals( VAR a , b : valuety );

VAR
   k: INTEGER;

BEGIN (* AddVals *)

   WITH a DO
                                   (* Integer result *)

      IF ( typ = INT ) AND ( b.typ = INT ) THEN
         BEGIN
            i := i + b.i;
            k := i;
            r := k;
         END
      ELSE                         (* Real result *)
         BEGIN
            i   := 0;
            r   := r + b.r;
            typ := rea;
         END

END  (* AddVals *);

(*--------------------------------------------------------------------------*)
(*                    SubVals --- Subtract two values                       *)
(*--------------------------------------------------------------------------*)

PROCEDURE SubVals( VAR a , b : valuety );

VAR
   k: INTEGER;

BEGIN  (* SubVals *)

   WITH a DO
      IF ( typ = INT ) AND ( b.typ = INT ) THEN

         BEGIN                     (* Integer result *)
            i := i - b.i;
            k := i;
            r := k;
         END
      ELSE
         BEGIN                     (* Real result *)
            i   := 0;
            r   := r - b.r;
            typ := rea;
         END;

END   (* SubVals *);

(*--------------------------------------------------------------------------*)
(*                    MulVals --- Multiply two values                       *)
(*--------------------------------------------------------------------------*)

PROCEDURE MulVals( VAR a , b : valuety );

VAR
   k: INTEGER;

BEGIN  (* MulVals *)

   WITH a DO
      IF ( typ = INT ) AND ( b.typ = INT ) THEN

         BEGIN                     (* Integer result *)
            i := i * b.i;
            k := i;
            r := k;
         END
      ELSE
         BEGIN                     (* Real result *)
            i   := 0;
            r   := r * b.r;
            typ := rea;
         END;

END   (* MulVals *);

(*--------------------------------------------------------------------------*)
(*                   RdivVals --- Divide two values (real division)         *)
(*--------------------------------------------------------------------------*)

PROCEDURE RdivVals( VAR a , b : valuety );

BEGIN  (* RdivVals *)

   WITH a DO
      BEGIN
                                   (* Issue error on zero divide *)
         IF b.r = 0.0 THEN
            Error('Division by zero')
         ELSE
            BEGIN
               i   := 0;
               r   := r / b.r;
               typ := rea;
            END;

      END;

END  (* RdivVals *);

(*--------------------------------------------------------------------------*)
(*               IdivVals --- Divide two values (integer division)          *)
(*--------------------------------------------------------------------------*)

PROCEDURE IdivVals( VAR a , b : valuety );

VAR
   k: INTEGER;

BEGIN (* IdivVals *)

   WITH a DO
      BEGIN
                                   (* Ensure both operands are integers *)

         IF ( typ <> INT ) OR ( b.typ <> INT ) THEN
            Error('DIV operands must both be integers')
         ELSE
            BEGIN                  (* Check for zero divide *)
               IF b.i = 0 THEN
                  Error ('Division by zero')
               ELSE
                  BEGIN

                     i := i DIV b.i;
                     k := i;
                     r := k;

                  END;

            END;

      END;

END  (* IdivVals *);

(*--------------------------------------------------------------------------*)
(*                      ModVals --- MOD operation                           *)
(*--------------------------------------------------------------------------*)

PROCEDURE ModVals( VAR a , b : valuety );

VAR
   k: INTEGER;

BEGIN (* ModVals *)

   WITH a DO
      BEGIN
                                   (* Ensure both operands are integers *)

         IF ( typ <> INT ) OR ( b.typ <> INT ) THEN
            Error('MOD operands must both be integers')

         ELSE                      (* Don't allow MOD 0 *)
            BEGIN
               IF b.i = 0 THEN
                  error ('MOD 0 illegal')
               ELSE
                  BEGIN

                     i := i MOD b.i;
                     k := i;
                     r := k;

                  END;

           END;

      END;

END  (* ModVals *);

(*--------------------------------------------------------------------------*)
(*                   PowVals --- exponentiation operation                   *)
(*--------------------------------------------------------------------------*)

PROCEDURE PowVals( VAR a , b : valuety );

VAR
   k: INTEGER;

BEGIN (* Powvals *)

   WITH a DO
      BEGIN

         i := 0;

         CASE b.typ OF
                                   (* Power is integer *)
            INT: BEGIN
                                   (* Don't allow 0 ** (<= 0) *)

                    IF r = 0.0 THEN IF b.i <= 0 THEN
                       Error('Bad arguments for exponentiation')
                    ELSE
                       BEGIN

                          r := PowerI( r , b.i );

                                   (* Round if integer result required *)

                          IF ( typ = INT ) AND ( b.i >= 0 ) THEN
                             BEGIN
                                i := ROUND(r);
                                k := i;
                                r := k;
                             END
                          ELSE
                             typ := rea;

                       END;

                 END;
                                   (* Real exponent *)

            rea: BEGIN  (* REA *)

                                   (* Don't allow 0 ** ( <= 0 ), or *)
                                   (* (<= 0) ** ( <= 0 )            *)

                    IF r < 0.0 THEN
                       Error('Bad arguments for exponentiation')
                    ELSE IF r = 0.0 THEN IF b.r <= 0.0 THEN
                       Error('Bad arguments for exponentiation')
                    ELSE
                       BEGIN

                          r   := Power( r , b.r );
                          typ := rea;

                       END (* IF *)

                 END  (* REA *)

         END  (*  CASE *)

   END  (* WITH *)

END (* POWVALS *);